;;;;    Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(use-modules (ice-9 pretty-print))

(define expansion-eval-closure (make-fluid))

(define (env->eval-closure env)
  (or (and env
           (car (last-pair env)))
      (module-eval-closure the-root-module)))

(define sc-macro
  (procedure->memoizing-macro
   (lambda (exp env)
     (with-fluids ((expansion-eval-closure (env->eval-closure env)))
       (sc-expand exp)))))

(define sc-expand #f)
(define sc-expand3 #f)
(define sc-chi #f)
(define install-global-transformer #f)
(define syntax-dispatch #f)
(define syntax-error #f)

(define bound-identifier=? #f)
(define datum->syntax-object #f)
(define free-identifier=? #f)
(define generate-temporaries #f)
(define identifier? #f)
(define syntax-object->datum #f)

(define primitive-syntax '(quote lambda letrec if set! begin define or
                                 and let let* cond do quasiquote unquote
                                 unquote-splicing case))

(for-each (lambda (symbol)
            (set-symbol-property! symbol 'primitive-syntax #t))
          primitive-syntax)

(define (void) *unspecified*)

(define andmap
  (lambda (f first . rest)
    (or (null? first)
        (if (null? rest)
            (let andmap ((first first))
              (let ((x (car first)) (first (cdr first)))
                (if (null? first)
                    (f x)
                    (and (f x) (andmap first)))))
            (let andmap ((first first) (rest rest))
              (let ((x (car first))
                    (xr (map car rest))
                    (first (cdr first))
                    (rest (map cdr rest)))
                (if (null? first)
                    (apply f (cons x xr))
                    (and (apply f (cons x xr)) (andmap first rest)))))))))

(define (error who format-string why what)
  (start-stack 'syncase-stack
               (scm-error 'misc-error
                          who
                          "~A ~S"
                          (list why what)
                          '())))

(define the-syncase-module (current-module))
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))

(fluid-set! expansion-eval-closure the-syncase-eval-closure)

(define (putprop symbol key binding)
  (let* ((eval-closure (fluid-ref expansion-eval-closure))
         ;; Why not simply do (eval-closure symbol #t)?
         ;; Answer: That would overwrite imported bindings
         (v (or (eval-closure symbol #f) ;lookup
                (eval-closure symbol #t) ;create it locally
                )))
    ;; Don't destroy Guile macros corresponding to
    ;; primitive syntax when syncase boots.
    (if (not (and (symbol-property symbol 'primitive-syntax)
                  (eq? eval-closure the-syncase-eval-closure)))
        (variable-set! v sc-macro))
    ;; Properties are tied to variable objects
    (set-object-property! v key binding)))

(define (getprop symbol key)
  (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
    (and v
         (or (object-property v key)
             (and (variable-bound? v)
                  (macro? (variable-ref v))
                  (macro-transformer (variable-ref v)) ;non-primitive
                  guile-macro)))))

(define guile-macro
  (cons 'external-macro
        (lambda (e r w s)
          (let ((e (syntax-object->datum e)))
            (if (symbol? e)
                ;; pass the expression through
                e
                (let* ((eval-closure (fluid-ref expansion-eval-closure))
                       (m (variable-ref (eval-closure (car e) #f))))
                  (if (eq? (macro-type m) 'syntax)
                      ;; pass the expression through
                      e
                      ;; perform Guile macro transform
                      (let ((e ((macro-transformer m)
                                e
                                (append r (list eval-closure)))))
                        (if (variable? e)
                            e
                            (if (null? r)
                                (sc-expand e)
                                (sc-chi e r w)))))))))))

(define gensym
  (let ((counter 0))
    (define next-id
      (lambda ()
        (let ((result counter))
          (set! counter (+ counter 1))
          result)))

    ;; actual gensym body code.
    (lambda (. rest)
      (let* ((next-val (next-id))
             (valstr (number->string next-val)))
        (cond
         ((null? rest)
          (string->symbol (string-append "syntmp-" valstr)))
         ((null? (cdr rest))
          (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
         (else
          (error
           (string-append
            "syncase's gensym expected 0 or 1 arguments, got "
            (length rest)))))))))

(load-from-path "ice-9/psyntax.ss")

(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))

(define (eval x environment)
  (internal-eval (if (and (pair? x)
                          (equal? (car x) "noexpand"))
                     (cadr x)
                     (sc-expand x))
                 environment))

(define (syncase exp)
  (with-fluids ((expansion-eval-closure
                 (module-eval-closure (current-module))))
    (sc-expand exp)))

(set-module-transformer! the-syncase-module syncase)

(fluid-set! expansion-eval-closure (env->eval-closure #f))

(let* ((top_srcdir (assoc-ref %guile-build-info 'top_srcdir))
       (source (string-append top_srcdir "/ice-9/psyntax.ss"))
       (target (string-append top_srcdir "/ice-9/psyntax.pp"))
       (temp (string-append target ".tmp")))
  (call-with-input-file source
    (lambda (in)
      (call-with-output-file temp
        (lambda (out)
          (display ";;; -*- mode: scheme; geiser-scheme-implementation: guile -*-" out)
          (newline out)
          (let loop ((x (read in)))
            (if (eof-object? x)
                (begin
                  (close-port out)
                  (close-port in))
                (begin
                  (pretty-print (sc-expand3 x 'c '(compile load eval)) out)
                  (newline out)
                  (loop (read in)))))))))
  (system* "mv" "-f" temp target))
